Dimkid: Topic Modeling (LDA)

Setup

Data preparation

Topic modeling

Adults, 7-point scale

# make wideframe df
d1b_prep <- d1b %>%
  select(subid, age, character, capacity, responseNum) %>%
  mutate(age = as.numeric(as.character(age))) %>%
  spread(capacity, responseNum) %>%
  arrange(age) %>%
  remove_rownames() %>%
  column_to_rownames("subid")
# limit to complete cases for tsne
d1b_all_complete <- d1b_prep[complete.cases(d1b_prep),]
# make LDA-friendly df
d1b_LDA <- d1b_all_complete %>%
  rownames_to_column("subid") %>%
  select(-age, -character) %>%
  gather(capacity, response, -subid) %>%
  mutate(response = ifelse(response > 0, 1, response)) # legit?
  # mutate(response = (response * 2)) # is this legit? not counts...
d1b_LDA_keep <- d1b_LDA %>%
  ungroup() %>%
  group_by(subid) %>%
  summarise(sum = sum(response, na.rm = T)) %>%
  filter(sum != 0) %>%
  mutate(subid = as.character(subid))
  
d1b_LDA <- d1b_LDA %>%
  filter(subid %in% d1b_LDA_keep$subid) %>%
  ungroup() %>%
  spread(capacity, response) %>%
  remove_rownames() %>%
  column_to_rownames("subid")
# do LDA
d1b_LDA <- LDA(x = d1b_LDA, k = 10)

# look at terms by topic
d1b_LDA_topics <- tidy(d1b_LDA, matrix = "beta")
d1b_LDA_termorder <- d1b_LDA_topics %>%
  group_by(term) %>%
  top_n(1, beta) %>%
  arrange(topic, desc(beta)) %>%
  data.frame() %>%
  rownames_to_column("order") %>%
  mutate(order = as.numeric(as.character(order)))
ggplot(d1b_LDA_topics %>%
         full_join(d1b_LDA_termorder %>% select(term, order)) %>%
         distinct(),
       aes(x = topic, y = reorder(term, desc(order)), fill = beta)) +
  geom_tile() +
  scale_fill_distiller(palette = "YlGn", direction = 1,
                       guide = guide_colorbar(title = element_blank(),
                                              barheight = 10)) +
  theme_minimal()

Joining, by = "term"

# look at topics by "document" (participant)
d1b_LDA_documents <- tidy(d1b_LDA, matrix = "gamma") %>%
  rename(subid = document)
d1b_LDA_docorder <- d1b_LDA_documents %>%
  group_by(subid) %>%
  top_n(1, gamma) %>%
  arrange(topic, desc(gamma)) %>%
  data.frame() %>%
  rownames_to_column("order") %>%
  mutate(order = as.numeric(as.character(order))) %>%
  full_join(d1b_all_complete %>% 
              rownames_to_column("subid") %>% 
              select(subid, age, character))

Joining, by = "subid"

# ggplot(d1b_LDA_documents %>%
#          full_join(d1b_LDA_docorder %>% select(subid, order)),
#        aes(x = topic, y = reorder(subid, desc(order)), fill = gamma)) +
#   geom_tile() +
#   scale_fill_distiller(palette = "RdYlBu", 
#                        guide = guide_colorbar(title = element_blank(),
#                                               barheight = 10)) +
#   theme_minimal()
ggplot(d1b_LDA_documents %>% 
         full_join(d1b_LDA_docorder) %>% 
         filter(!is.na(character), !is.na(topic)) %>%
         distinct(),
       aes(x = age, y = gamma, color = factor(topic))) +
  # facet_wrap(~ topic) +
  facet_grid(character ~ topic) +
  geom_point() +
  # geom_smooth(method = "lm") +
  theme_bw()

Joining, by = c("subid", "topic", "gamma")

4-10yo

# make LDA-friendly df
d_slide_LDA <- d_slide_all_complete %>%
  rownames_to_column("subid") %>%
  select(-age, -character) %>%
  gather(capacity, response, -subid) %>%
  mutate(response = ifelse(response > 0, 1, response)) # legit?
  # mutate(response = (response * 2)) # is this legit? not counts...
d_slide_LDA_keep <- d_slide_LDA %>%
  ungroup() %>%
  group_by(subid) %>%
  summarise(sum = sum(response, na.rm = T)) %>%
  filter(sum != 0) %>%
  mutate(subid = as.character(subid))
  
d_slide_LDA <- d_slide_LDA %>%
  filter(subid %in% d_slide_LDA_keep$subid) %>%
  ungroup() %>%
  spread(capacity, response) %>%
  remove_rownames() %>%
  column_to_rownames("subid")
# do LDA
d_slide_LDA <- LDA(x = d_slide_LDA, k = 3)

# look at terms by topic
d_slide_LDA_topics <- tidy(d_slide_LDA, matrix = "beta")
d_slide_LDA_termorder <- d_slide_LDA_topics %>%
  group_by(term) %>%
  top_n(1, beta) %>%
  arrange(topic, desc(beta)) %>%
  data.frame() %>%
  rownames_to_column("order") %>%
  mutate(order = as.numeric(as.character(order)))
ggplot(d_slide_LDA_topics %>%
         full_join(d_slide_LDA_termorder %>% select(term, order)) %>%
         distinct(),
       aes(x = topic, y = reorder(term, desc(order)), fill = beta)) +
  geom_tile() +
  scale_fill_distiller(palette = "YlGn", direction = 1,
                       guide = guide_colorbar(title = element_blank(),
                                              barheight = 10)) +
  scale_x_continuous(breaks = 1:10) +
  theme_minimal()

Joining, by = "term"

# look at topics by "document" (participant)
d_slide_LDA_documents <- tidy(d_slide_LDA, matrix = "gamma") %>%
  rename(subid = document)
d_slide_LDA_docorder <- d_slide_LDA_documents %>%
  group_by(subid) %>%
  top_n(1, gamma) %>%
  arrange(topic, desc(gamma)) %>%
  data.frame() %>%
  rownames_to_column("order") %>%
  mutate(order = as.numeric(as.character(order))) %>%
  full_join(d_slide_all_complete %>% 
              rownames_to_column("subid") %>% 
              select(subid, age, character))

Joining, by = "subid"

# ggplot(d_slide_LDA_documents %>%
#          full_join(d_slide_LDA_docorder %>% select(subid, order)),
#        aes(x = topic, y = reorder(subid, desc(order)), fill = gamma)) +
#   geom_tile() +
#   scale_fill_distiller(palette = "RdYlBu", 
#                        guide = guide_colorbar(title = element_blank(),
#                                               barheight = 10)) +
#   theme_minimal()
ggplot(d_slide_LDA_documents %>% 
         full_join(d_slide_LDA_docorder %>% select(subid, character, age)) %>% 
         filter(!is.na(character), !is.na(topic)) %>%
         distinct(),
       aes(x = age, y = gamma, 
           # color = character, fill = character)) +
           color = factor(topic), fill = factor(topic))) +
  # facet_grid(~ topic) +
  facet_grid(character ~ topic) +
  geom_point() +
  geom_smooth(method = "lm") +
  theme_bw()

Joining, by = "subid"

library(plotly)
plot_ly(d_slide_LDA_documents %>%
          mutate(topic = recode(topic,
                                "1" = "topic_1",
                                "2" = "topic_2",
                                "3" = "topic_3")) %>%
          spread(topic, gamma) %>%
          full_join(d_slide_LDA_docorder %>% 
                      select(subid, age, character)) %>%
          filter(!is.na(character)),
        x = ~topic_1, y = ~topic_2, z = ~topic_3,
        color = ~age,
        # color = ~character,
        # size = ~age,
        opacity = 0.6)

Joining, by = "subid"
No trace type specified:
  Based on info supplied, a 'scatter3d' trace seems appropriate.
  Read more about this trace type -> https://plot.ly/r/reference/#scatter3d
No scatter3d mode specifed:
  Setting the mode to markers
  Read more about this attribute -> https://plot.ly/r/reference/#scatter-mode
Ignoring 16 observationsNo trace type specified:
  Based on info supplied, a 'scatter3d' trace seems appropriate.
  Read more about this trace type -> https://plot.ly/r/reference/#scatter3d
No scatter3d mode specifed:
  Setting the mode to markers
  Read more about this attribute -> https://plot.ly/r/reference/#scatter-mode
Ignoring 16 observations